home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
soundu
/
dilaudid.zip
/
NEW
/
DG.BAS
< prev
next >
Wrap
BASIC Source File
|
1994-03-28
|
43KB
|
1,392 lines
DEFINT A-Z
DECLARE FUNCTION words (text$)
DECLARE FUNCTION BuildChord$ (croot, ctype)
DECLARE FUNCTION GetNotes$ (starttime, endtime)
DECLARE FUNCTION GetWord$ (orig$, wordno)
DECLARE FUNCTION Modify (initial, change, irlo, irhi, degree)
DECLARE FUNCTION Note2Num (note$)
DECLARE FUNCTION Num2Note$ (number)
DECLARE FUNCTION Round$ (initial$, newnote1$, scaletype, size)
DECLARE FUNCTION ScaleNum (initial, irlo, irhi, orlo, orhi, inv)
DECLARE FUNCTION Trim$ (orig$)
DECLARE SUB Arpeg ()
DECLARE SUB ViewComp ()
DECLARE SUB Life ()
DECLARE SUB Quit ()
DECLARE SUB Add ()
DECLARE SUB Load ()
DECLARE SUB Save ()
DECLARE SUB Cellular ()
DECLARE SUB Move ()
DECLARE SUB DeleteNotes ()
DECLARE SUB SaveText (filename$)
DECLARE SUB RandomNotes ()
DECLARE SUB Generate ()
DECLARE SUB Wave ()
DECLARE SUB Mountain ()
COMMON SHARED notes()
DIM SHARED notes(1 TO 11, 1 TO 3, 0 TO 700)
'how notes are stored:
' (1) they are stored in the notes array,
' (2) notes has three subscripts:
' (a) 1 to 11: specifies channel number
' (b) 1 to 2: 1 is the note's time location,
' 2 is the note frequency number
' 3 is the note duration
' (c) 1 to 500: are the notes themselves,
' 0 is the top note number
'when notes are added, check to if they go before any notes that are
'already present. if so, move those notes first so that the whole array
'stays in order.
FOR r = 1 TO 11
notes(r, 1, 0) = 0
NEXT
start:
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
PRINT " 1. View composition"
PRINT " 2. Play composition/Adlib"
PRINT " 3. Add notes"
PRINT " 4. Generate pattern"
PRINT " 5. Delete notes"
PRINT " 6. Move notes"
PRINT
PRINT " 7. Load sequence"
PRINT " 8. Save sequence"
PRINT " 9. Save text"
PRINT "10. Quit"
PRINT
LINE INPUT "-->", x$
sel = VAL(x$)
SELECT CASE sel
CASE 1 'view composition
ViewComp
CASE 2 'play composition
SaveText "SEQ.TXT"
SHELL "PLAY SEQ.TXT"
CASE 3 'add notes
Add
CASE 4 'generate pattern
Generate
CASE 5 'delete notes
DeleteNotes
CASE 6 'move notes
Move
CASE 7 'load sequence
Load
CASE 8 'save sequence
Save
CASE 9 'save as text
SaveText ""
CASE 10 'quit
Quit
END SELECT
GOTO start
SUB Add
'Add a section of notes
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System ( X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
PRINT STRING$(80, "-")
PRINT ".NOT files are text note lists, .CEL files are binary information lists"
PRINT
x$ = DIR$("*.CEL")
IF x$ <> "" THEN
PRINT x$,
DO
x$ = DIR$
IF x$ = "" THEN EXIT DO
PRINT x$,
LOOP
END IF
x$ = DIR$("*.NOT")
IF x$ <> "" THEN
PRINT x$,
DO
x$ = DIR$
IF x$ = "" THEN EXIT DO
PRINT x$,
LOOP
END IF
PRINT
PRINT
LINE INPUT "Channel # ---------->", channel$
LINE INPUT "Main filename ------>", filename$
IF UCASE$(RIGHT$(" " + filename$, 3)) <> "NOT" THEN
LINE INPUT "Note range start --->", notestart$
LINE INPUT "Note range end ----->", noteend$
ELSE
notestart$ = "C": noteend$ = "c"
END IF
' SCALE TYPES
' -----------
PRINT " '0=chromatic"
PRINT " '1=whole tone starting on C"
PRINT " '2=whole tone starting on C+"
PRINT " '3=diatonic/c-major"
PRINT " '4=spooky"
PRINT " '5=black keys"
PRINT " '6=indian"
LINE INPUT "Scale type (0-6) --->", scaletype$
scaletype = VAL(scaletype$)
LINE INPUT "Rounding buffer ---->", size$
size = VAL(size$)
LINE INPUT "Spacing style (ox) ->", spacing$
IF spacing$ = "" THEN
LINE INPUT "Note length (16ths)->", notelen$
notelen = VAL(notelen$)
ELSE
LINE INPUT "Spacing repeats ---->", spacerep$
END IF
LINE INPUT "Time place start --->", timestart$
timestart = ((VAL(timestart$) - 1) * 16) + 1
IF timestart = 0 THEN timestart = 1
IF spacing$ = "" THEN
LINE INPUT "Time length -------->", timelen$
timelen = VAL(timelen$) * 16
END IF
LINE INPUT "# repeats ---------->", repeats$
repeats = VAL(repeats$)
IF repeats = 0 THEN repeats = 1
LINE INPUT "Degree variation --->", degreev$
degreev = VAL(degreev$)
LINE INPUT "Repeat filename ---->", rfilename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
channel = VAL(channel$)
IF channel < 1 THEN channel = 1
IF channel > 11 THEN channel = 11
notestart = Note2Num(notestart$)
noteend = Note2Num(noteend$)
'get number of notes / repeated section
IF spacing$ <> "" THEN
spacing$ = Trim$(spacing$)
numnotesb = words(spacing$)
spacerep = VAL(spacerep$)
numnotes = spacerep * numnotesb
ELSE
numnotes = timelen / notelen
END IF
REDIM temp(numnotes)
'load and scale notes
IF UCASE$(RIGHT$(filename$, 3)) = "NOT" THEN
OPEN filename$ FOR BINARY AS #1
FOR r = 1 TO numnotes
x$ = ""
DO
x$ = x$ + INPUT$(1, #1)
IF EOF(1) THEN EXIT DO
IF RIGHT$(x$, 1) = " " THEN EXIT DO
LOOP
temp(r) = Note2Num(Trim$(x$))
NEXT
ELSE
OPEN filename$ FOR BINARY AS #1
FOR r = 1 TO numnotes
IF LOC(1) = LOF(1) THEN SEEK #1, 1
init = ASC(INPUT$(1, #1))
temp(r) = ScaleNum(init, 0, 255, notestart, noteend, 0)
NEXT
END IF
CLOSE
'do repeat loop, copying notes to main array
IF rfilename$ <> "" THEN
varying = 1
OPEN rfilename$ FOR BINARY AS #1
ELSE
varying = 0
END IF
countnotes = 0
r1 = timestart
FOR r = 1 TO repeats
FOR n = 1 TO numnotes
PRINT ".";
IF varying THEN
vary = ASC(INPUT$(1, #1))
note = Modify(temp(n), vary, 0, 255, degreev)
ELSE
note = temp(n)
END IF
IF spacing$ = "" THEN
r1 = ((r - 1) * numnotes * notelen) + ((n - 1) * notelen) + timestart
ELSE
notelen = LEN(GetWord$(spacing$, ((n - 1) MOD numnotesb) + 1))
END IF
r2 = r1 + (notelen - 1)
rnotes$ = GetNotes$(r1, r2)
note = Note2Num(Round$(rnotes$, Num2Note$(note), scaletype, size))
IF spacing$ <> "" THEN
IF INSTR(GetWord$(spacing$, ((n - 1) MOD numnotesb) + 1), "o") THEN note = 0
END IF
IF note <> 0 THEN
countnotes = countnotes + 1
al = notes(channel, 1, 0) + countnotes
notes(channel, 1, al) = r1
notes(channel, 2, al) = note
notes(channel, 3, al) = notelen
END IF
r1 = r1 + notelen
NEXT
NEXT
notes(channel, 1, 0) = notes(channel, 1, 0) + countnotes
IF rfilename$ <> "" THEN
CLOSE
END IF
ERASE temp
END SUB
SUB Arpeg
CLS
REDIM as$(3 TO 9)
PRINT "Dilaudid Glide"
PRINT "Music Authoring System ( X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "Chord sequence ----->", chords$
IF INSTR(chords$, "3") THEN LINE INPUT "Arpeggio style 3rd ->", as$(3)
IF INSTR(chords$, "4") THEN LINE INPUT "Arpeggio style 4th ->", as$(4)
IF INSTR(chords$, "5") THEN LINE INPUT "Arpeggio style 5th ->", as$(5)
IF INSTR(chords$, "7") THEN LINE INPUT "Arpeggio style 7th ->", as$(7)
IF INSTR(chords$, "9") THEN LINE INPUT "Arpeggio style 9th ->", as$(9)
LINE INPUT "Filename (8 chars) ->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN ERASE as$: EXIT SUB
IF filename$ = "" THEN ERASE as$: EXIT SUB
filename$ = filename$ + ".NOT"
numchords = words(chords$)
OPEN filename$ FOR OUTPUT AS #1
FOR c = 1 TO numchords
PRINT ".";
chord$ = GetWord(chords$, c)
ctype = VAL(RIGHT$(chord$, 1))
croot = Note2Num(MID$(chord$, 1, LEN(chord$) - 1))
chord$ = BuildChord$(croot, ctype)
numnotes = words(as$(ctype))
FOR n = 1 TO numnotes
PRINT #1, GetWord$(chord$, VAL(GetWord$(as$(ctype), n))) + " ";
NEXT
NEXT
CLOSE
ERASE as$
END SUB
FUNCTION BuildChord$ (croot, ctype)
temp$ = ""
SELECT CASE ctype
CASE 4
temp$ = Num2Note$(croot + 0) + " "
temp$ = temp$ + Num2Note$(croot + 5) + " "
temp$ = temp$ + Num2Note$(croot + 11) + " "
temp$ = temp$ + Num2Note$(croot + 16)
CASE 3, 5, 7, 9
n = 2 + ((ctype - 3) / 2)
temp$ = Num2Note$(croot) + " "
temp$ = temp$ + Num2Note$(croot + 4) + " "
temp$ = temp$ + Num2Note$(croot + 7) + " "
IF ctype > 3 THEN temp$ = temp$ + Num2Note$(croot + 11) + " "
IF ctype > 5 THEN temp$ = temp$ + Num2Note$(croot + 14) + " "
IF ctype > 7 THEN temp$ = temp$ + Num2Note$(croot + 17)
END SELECT
BuildChord$ = Trim$(temp$)
END FUNCTION
SUB Cellular
'do a cellular automata generation
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "K1 (1-10,2) --------->", k1$
LINE INPUT "K2 (1-10,3) --------->", k2$
LINE INPUT "Spd (1-20,4) -------->", spd$
LINE INPUT "Row start (1-35) ---->", row1$
LINE INPUT "Number of rows ------>", norow$
LINE INPUT "Col start (1-35) ---->", col1$
LINE INPUT "number of cols ------>", nocol$
LINE INPUT "Time start ---------->", time1$
LINE INPUT "Duration ------------>", duration$
LINE INPUT "Random seed --------->", seed$
LINE INPUT "Output filename (8) ->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
IF filename$ = "" THEN EXIT SUB
k1 = VAL(k1$)
k2 = VAL(k2$)
g = VAL(spd$) 'infection rate
out$ = filename$ + ".CEL"
sx = VAL(row1$)
ex = sx + VAL(norow$) - 1
sy = VAL(col1$)
ey = sx + VAL(nocol$) - 1
time1 = VAL(time1$)
time2 = time1 + VAL(duration$) - 1
RANDOMIZE VAL(seed$)
REDIM array1(0 TO 36, 0 TO 36)
REDIM array2(0 TO 36, 0 TO 36)
FOR r = 1 TO 35
FOR c = 1 TO 35
array1(r, c) = (INT(RND * 254))
NEXT
NEXT
SCREEN 13
OUT &H3C8, 1
FOR r = 1 TO 127
OUT &H3C9, (r * 127) \ 254
OUT &H3C9, 0
OUT &H3C9, 63 - (r * 127) \ 254
NEXT
FOR r = 128 TO 254
OUT &H3C9, 63 - ((r - 127) * 127) \ 254
OUT &H3C9, 0
OUT &H3C9, 0
NEXT
DEF SEG = &HA000
FOR c = 1 TO 254
POKE (199 * 320) + c, c
NEXT
IF out$ <> "" THEN OPEN out$ FOR OUTPUT AS #1
timeat = 0
DO
timeat = timeat + 1
IF out$ <> "" AND timeat >= time1 THEN
FOR r = sx TO ex
FOR c = sy TO ey
PRINT #1, CHR$((array1(r, c)) + 1);
NEXT
NEXT
END IF
FOR r = 1 TO 35
FOR c = 1 TO 35
POKE (r * 320) + c, (array1(r, c)) + 1
array2(r, c) = array1(r, c)
NEXT
NEXT
LINE (sx - 1, sy - 1)-(ex + 1, ey + 1), 0, B
FOR r = 1 TO 35
FOR c = 1 TO 35
IF (array2(r, c)) = 254 THEN 'ill cells
array1(r, c) = (0)
ELSEIF (array2(r, c)) = 0 THEN 'healthy cells
aa = 0: bb = 0
IF (array2(r + 1, c)) > 0 AND (array2(r + 1, c)) < 254 THEN aa = 1 ELSE IF (array2(r + 1, c)) = 254 THEN bb = 1
IF (array2(r - 1, c)) > 0 AND (array2(r - 1, c)) < 254 THEN aa = aa + 1 ELSE IF (array2(r - 1, c)) = 254 THEN bb = bb + 1
IF (array2(r, c + 1)) > 0 AND (array2(r, c + 1)) < 254 THEN aa = aa + 1 ELSE IF (array2(r, c + 1)) = 254 THEN bb = bb + 1
IF (array2(r, c - 1)) > 0 AND (array2(r, c - 1)) < 254 THEN aa = aa + 1 ELSE IF (array2(r, c - 1)) = 254 THEN bb = bb + 1
array1(r, c) = ((aa \ k1) + (bb \ k2))
ELSE 'infected cells
aa = 0: ss = 0
IF (array2(r + 1, c)) > 0 AND (array2(r + 1, c)) < 254 THEN aa = aa + 1: ss = ss + (array2(r + 1, c))
IF (array2(r - 1, c)) > 0 AND (array2(r - 1, c)) < 254 THEN aa = aa + 1: ss = ss + (array2(r - 1, c))
IF (array2(r, c + 1)) > 0 AND (array2(r, c + 1)) < 254 THEN aa = aa + 1: ss = ss + (array2(r, c + 1))
IF (array2(r, c - 1)) > 0 AND (array2(r, c - 1)) < 254 THEN aa = aa + 1: ss = ss + (array2(r, c - 1))
IF aa = 0 THEN
array1(r, c) = array2(r, c)
ELSE
array1(r, c) = ((ss \ aa) + g)
END IF
END IF
IF (array1(r, c)) > 254 THEN array1(r, c) = (254)
NEXT
NEXT
LOOP UNTIL timeat > time2
IF out$ <> "" THEN CLOSE
SCREEN 0
WIDTH 80
ERASE array1, array2
END SUB
SUB DeleteNotes
'Delete a section of notes
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "Channel # ---------->", channel$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
channel = VAL(channel$)
IF channel < 1 THEN channel = 1
IF channel > 11 THEN channel = 11
'reset topnote
notes(channel, 1, 0) = 0
END SUB
SUB Generate
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System ( X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
PRINT STRING$(80, "-")
PRINT
PRINT "1. Cellular"
PRINT "2. Wave"
PRINT "3. Random"
PRINT "4. Mountain range"
PRINT "5. Life simulation"
PRINT "6. Arpeggiator"
PRINT
LINE INPUT "-->", x$
sel = VAL(x$)
SELECT CASE sel
CASE 1 'cellular
Cellular
CASE 2 'wave
Wave
CASE 3 'random
RandomNotes
CASE 4 'mountain range
Mountain
CASE 5 'life
Life
CASE 6 'Arpeggiator
Arpeg
END SELECT
END SUB
FUNCTION GetNotes$ (starttime, endtime)
'Figure out what notes are playing in a specific period of time
FOR chan = 1 TO 11
top = notes(chan, 1, 0)
IF top > 0 THEN
FOR at = 1 TO top
timeloc = notes(chan, 1, at)
duration = notes(chan, 3, at)
noteend = timeloc + (duration - 1)
IF (starttime <= timeloc AND endtime >= timeloc) OR (starttime <= noteend AND endtime >= noteend) THEN
note$ = note$ + Num2Note(notes(chan, 2, at)) + " "
ELSE
IF timeloc > endtime THEN EXIT FOR
END IF
NEXT
END IF
NEXT
GetNotes$ = Trim$(note$)
END FUNCTION
FUNCTION GetWord$ (orig$, wordno)
'Get a word from a sentance
IF wordno = 1 THEN
x = INSTR(orig$, " ")
IF x = 0 THEN
t$ = orig$
ELSE
t$ = MID$(orig$, 1, x - 1)
END IF
ELSE
t$ = orig$
at = 2
DO
x = INSTR(t$, " ")
IF x = 0 THEN
t$ = ""
EXIT DO
ELSE
t$ = MID$(t$, x + 1)
IF at = wordno THEN
x = INSTR(t$, " ")
IF x <> 0 THEN
t$ = MID$(t$, 1, x - 1)
END IF
EXIT DO
END IF
END IF
at = at + 1
LOOP
END IF
GetWord$ = t$
END FUNCTION
SUB Life
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "Row start (1-35) ---->", row1$
LINE INPUT "Number of rows ------>", norow$
LINE INPUT "Col start (1-35) ---->", col1$
LINE INPUT "number of cols ------>", nocol$
LINE INPUT "Time start ---------->", time1$
LINE INPUT "Duration ------------>", duration$
LINE INPUT "Random seed --------->", seed$
LINE INPUT "Output filename (8) ->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
IF filename$ = "" THEN EXIT SUB
out$ = filename$ + ".CEL"
sx = VAL(row1$)
ex = sx + VAL(norow$) - 1
sy = VAL(col1$)
ey = sx + VAL(nocol$) - 1
time1 = VAL(time1$)
time2 = time1 + VAL(duration$) - 1
RANDOMIZE VAL(seed$)
REDIM array1(1 TO 35, 1 TO 35)
REDIM array2(1 TO 35, 1 TO 35)
SCREEN 13
CLS
FOR r = 1 TO 35
FOR t = 1 TO 35
x = RND * 256
array1(r, t) = x
NEXT
NEXT
OUT &H3C8, 1
FOR r = 1 TO 127
OUT &H3C9, (r * 127) \ 254
OUT &H3C9, 0
OUT &H3C9, 63 - (r * 127) \ 254
NEXT
FOR r = 128 TO 254
OUT &H3C9, 63 - ((r - 127) * 127) \ 254
OUT &H3C9, 0
OUT &H3C9, 0
NEXT
DEF SEG = &HA000
IF out$ <> "" THEN OPEN out$ FOR OUTPUT AS #1
timeat = 0
DO
FOR r = 1 TO 35
FOR t = 1 TO 35
orig = array1(r, t)
ab = r - 1: IF ab = 0 THEN ab = 35
bl = r + 1: IF bl = 36 THEN bl = 1
lt = t + 1: IF lt = 36 THEN lt = 1
rt = t - 1: IF rt = 0 THEN rt = 35
avgn = (array1(ab, t) + array1(bl, t) + array1(r, lt) + array1(r, rt)) \ 4
IF orig < 251 AND orig > 9 THEN
SELECT CASE avgn
CASE IS > 230
orig = orig \ 3 + avgn \ 2
CASE 80 TO 229
orig = (orig * 2 + avgn) \ 3
CASE ELSE
orig = (orig + avgn * 2) \ 3
END SELECT
END IF
IF orig > 130 THEN orig = orig + 4 ELSE orig = orig - 2
IF orig <= 0 THEN orig = 255
IF orig > 255 THEN orig = 255
IF orig < 10 THEN
array1(r, lt) = ((array1(r, lt) + 44) + array1(ab, lt)) \ 2
IF array1(r, lt) > 255 THEN array1(r, lt) = 255
array1(r, rt) = ((array1(r, rt) + 44) + array1(ab, rt)) \ 2
IF array1(r, rt) > 255 THEN array1(r, rt) = 255
array2(r, rt) = array1(r, rt)
array2(r, lt) = array1(r, lt)
END IF
IF orig > 250 THEN
array1(ab, t) = ((array1(ab, t) \ 3) + array1(ab, lt)) \ 2
array1(bl, t) = ((array1(bl, t) \ 3) + array1(bl, lt)) \ 2
array2(ab, t) = array1(ab, t)
array2(bl, t) = array1(bl, t)
END IF
array2(r, t) = orig
NEXT
NEXT
FOR r = 1 TO 35
FOR c = 1 TO 35
'POKE (r * 320) + c, (array2(r, c)) + 1
PSET (c, r), (array2(r, c)) + 1
array1(r, c) = array2(r, c)
NEXT
NEXT
LINE (sx - 1, sy - 1)-(ex + 1, ey + 1), 0, B
timeat = timeat + 1
IF out$ <> "" AND timeat >= time1 THEN
FOR r = sx TO ex
FOR c = sy TO ey
PRINT #1, CHR$((array1(r, c)));
NEXT
NEXT
END IF
LOOP UNTIL timeat > time2
SCREEN 0
WIDTH 80
CLOSE
ERASE array1, array2
END SUB
SUB Load
'Load a sequence array
x$ = DIR$("*.DGS")
IF x$ <> "" THEN
PRINT x$,
DO
x$ = DIR$
IF x$ = "" THEN EXIT DO
PRINT x$,
LOOP
END IF
PRINT
LINE INPUT "Filename (8 chars) -->", filename$
filename$ = Trim$(filename$)
IF filename$ = "" THEN EXIT SUB
LINE INPUT "Are you sure (y/N) -->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
filename$ = filename$ + ".DGS"
OPEN filename$ FOR BINARY AS #1
FOR r1 = 1 TO 11
PRINT ".";
FOR r2 = 1 TO 3
FOR r3 = 0 TO 500
notes(r1, r2, r3) = CVI(INPUT$(2, #1))
NEXT
NEXT
NEXT
CLOSE #1
END SUB
FUNCTION Modify (initial, change, irlo, irhi, degree)
'takes a note INITIAL, and a CHANGE value in the
'range IRLO-IRHI, and modifies INITIAL up to DEGREE
'steps
top = (irhi - irlo) / 2
temp = (change - irlo) - top 'from - to + range
chng = (temp / top) * degree 'calculate change
Modify = initial + chng
END FUNCTION
SUB Mountain
'generate a mountain range pattern
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "% conjunct jumps ---------->", conjunct$
LINE INPUT "% disjunct jumps ---------->", disjunct$
conjunct = VAL(conjunct$)
disjunct = VAL(disjunct$)
nonjunct = 100 - (conjunct + disjunct)
PRINT "% 'nonjunct' jumps -------->"; Trim$(STR$(nonjunct))
LINE INPUT "Conjunct jump size -------->", consize$
LINE INPUT "Disjunct jump size -------->", dissize$
consize = VAL(consize$)
dissize = VAL(dissize$)
LINE INPUT "Number of pattern buffers ->", nobuf$
nobuf = VAL(nobuf$)
IF nobuf THEN
LINE INPUT "Max size of buffer -------->", maxsize$
DIM patbuf(1 TO nobuf, -4 TO VAL(maxsize$))
'-4 = relative (-1=note,else=start pt)
'-3 = size
'-2 = start rec chance
'-1 = start play size
' 0 = beat lock
FOR r = 1 TO nobuf
PRINT "==BUFFFER " + Trim$(STR$(r)) + "=="
LINE INPUT " Buffer size ------------>", size$
LINE INPUT " Relative/Absolute (ra) ->", relabs$
LINE INPUT " Start record chance ---->", src$
LINE INPUT " Start play chance ------>", scpc$
LINE INPUT " Beat lock -------------->", bl$
IF MID$(LCASE$(relabs$), 1, 1) = "r" THEN patbuf(r, -4) = -1 ELSE patbuf(r, -4) = (RND * 128) + 64
patbuf(r, -3) = VAL(size$)
patbuf(r, -2) = VAL(src$)
patbuf(r, -1) = VAL(scpc$)
patbuf(r, 0) = VAL(bl$)
NEXT
END IF
LINE INPUT "Seed ---------------------->", seed$
RANDOMIZE VAL(seed$)
LINE INPUT "Length -------------------->", length$
length = VAL(length$)
LINE INPUT "Filename (8 chars) -------->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ------------>", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
IF filename$ = "" THEN EXIT SUB
filename$ = filename$ + ".CEL"
dir = RND * 2: pb = 0: pbloc = 0: pbbuf = 0
note = 128: rec = 0: recloc = 0: recbuf = 0
SCREEN 12
OPEN filename$ FOR OUTPUT AS #1
FOR r = 1 TO nobuf 'fill pattern buffers first
dir = RND * 2
FOR t = 1 TO patbuf(r, -3)
x = (RND * 100) + 1
SELECT CASE x
CASE 1 TO conjunct 'conjunct
change = RND * consize
CASE (conjunct + 1) TO (disjunct + conjunct + 1) 'disjunct
change = RND * dissize
IF dir THEN dir = 0 ELSE dir = 1
CASE ELSE 'nonjunct
change = 0
END SELECT
IF dir = 0 THEN change = -change
patbuf(r, t) = change
NEXT
NEXT
FOR r = 1 TO length
IF pb THEN
change = patbuf(pbbuf, pbloc)
pbloc = pbloc + 1
IF pbloc > patbuf(pbbuf, -3) THEN
pb = 0: pbloc = 0: pbbuf = 0
END IF
ELSE
x = (RND * 100) + 1
SELECT CASE x
CASE 1 TO conjunct 'conjunct
change = RND * consize
CASE (conjunct + 1) TO (disjunct + conjunct + 1) 'disjunct
change = RND * dissize
IF dir THEN dir = 0 ELSE dir = 1
CASE ELSE 'nonjunct
change = 0
END SELECT
IF dir = 0 THEN change = -change
FOR t = 1 TO nobuf
B = (r + 1) MOD patbuf(t, 0)
IF B = 0 AND recbuf <> t THEN
IF (RND * 100) < patbuf(t, -2) THEN
rec = 1: recbuf = t: recloc = 1
IF patbuf(t, -4) > -1 THEN
patbuf(t, -4) = note
END IF
EXIT FOR
END IF
END IF
NEXT
END IF
note = note + change
IF note > 255 THEN note = 255
IF note < 0 THEN note = 0
PRINT #1, CHR$(note);
LINE (r MOD 640, 0)-(r MOD 640, 255), 0
PSET (r MOD 640, note), 15
IF rec THEN
patbuf(recbuf, recloc) = change
recloc = recloc + 1
IF recloc > patbuf(recbuf, -3) THEN
rec = 0: recloc = 0: recbuf = 0
END IF
ELSE
FOR t = 1 TO nobuf
B = (r + 1) MOD patbuf(t, 0)
IF B = 0 AND pbbuf <> t THEN
IF (RND * 100) < patbuf(t, -1) THEN
pb = 1: pbbuf = t: pbloc = 1
IF patbuf(t, -4) > -1 THEN
note = patbuf(t, -4)
END IF
EXIT FOR
END IF
END IF
NEXT
END IF
NEXT
CLOSE #1
LOCATE 30, 1
PRINT "--Press any key to return to menu--";
DO UNTIL INKEY$ <> "": LOOP
SCREEN 0
END SUB
SUB Move
'Delete a section of notes
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "Channel # (0=ALL) -->", channel$
LINE INPUT "Distance ----------->", dist$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
c = VAL(channel$)
d = VAL(dist$) * 16
IF c = 0 THEN
c1 = 1: c2 = 11
ELSE
c1 = c: c2 = c
END IF
FOR c = c1 TO c2
PRINT ".";
nn = notes(c, 1, 0)
FOR n = 1 TO nn
notes(c, 1, n) = notes(c, 1, n) + d
NEXT
NEXT
END SUB
FUNCTION Note2Num (note$)
'converts a note string into a number 0-127
'note names range X: X" X' X x x' x" x: x; x= x*
'note number 60 is middle C (c')
SELECT CASE LCASE$(MID$(note$, 1, 1))
CASE "c"
basen = 0
CASE "d"
basen = 2
CASE "e"
basen = 4
CASE "f"
basen = 5
CASE "g"
basen = 7
CASE "a"
basen = 9
CASE "b"
basen = 11
CASE ELSE
Note2Num = 0
EXIT FUNCTION
END SELECT
IF INSTR(note$, "+") THEN basen = basen + 1
IF ASC(MID$(note$, 1, 1)) < 75 THEN
SELECT CASE RIGHT$(note$, 1)
CASE ":"
octave = 0
CASE CHR$(34)
octave = 1
CASE "'"
octave = 2
CASE ELSE
octave = 3
END SELECT
ELSE
SELECT CASE RIGHT$(note$, 1)
CASE "'"
octave = 5
CASE CHR$(34)
octave = 6
CASE ":"
octave = 7
CASE ";"
octave = 8
CASE "="
octave = 9
CASE "*"
octave = 10
CASE ELSE
octave = 4
END SELECT
END IF
Note2Num = (octave * 12) + basen
END FUNCTION
FUNCTION Num2Note$ (number)
'converts a number 0-127 into a note name string
'note names range X: X" X' X x x' x" x: x; x= x*
'note number 60 is middle C (c')
uc = 0 'upper case toggle
foot$ = "" 'footer
SELECT CASE number
CASE 0 TO 11 ' C: to B:
uc = 1: foot$ = ":"
CASE 12 TO 23 ' C" to B"
uc = 1: foot$ = CHR$(34)
CASE 24 TO 35 ' C' to B'
uc = 1: foot$ = "'"
CASE 36 TO 47 ' C to B
uc = 1
CASE 48 TO 59 ' c to b
CASE 60 TO 71 ' c' to b'
foot$ = "'"
CASE 72 TO 83 ' c" to b"
foot$ = CHR$(34)
CASE 84 TO 95 ' c: to b:
foot$ = ":"
CASE 96 TO 107 ' c; to b;
foot$ = ";"
CASE 108 TO 119 ' c= to b=
foot$ = "="
CASE 120 TO 127 ' c* to g*
foot$ = "*"
END SELECT
SELECT CASE (number MOD 12)
CASE 0
note$ = "c"
CASE 1
note$ = "c+"
CASE 2
note$ = "d"
CASE 3
note$ = "d+"
CASE 4
note$ = "e"
CASE 5
note$ = "f"
CASE 6
note$ = "f+"
CASE 7
note$ = "g"
CASE 8
note$ = "g+"
CASE 9
note$ = "a"
CASE 10
note$ = "a+"
CASE 11
note$ = "b"
END SELECT
IF uc = 1 THEN note$ = UCASE$(note$)
Num2Note$ = note$ + foot$
END FUNCTION
SUB Quit
'Quit program
LINE INPUT "Are you sure (y/N) -->", x$
IF LCASE$(LEFT$(x$, 1)) = "y" THEN
CLS
END
END IF
END SUB
SUB RandomNotes
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System ( X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
PRINT STRING$(80, "-")
PRINT
LINE INPUT "Number of notes ---->", numnotes$
LINE INPUT "Seed --------------->", seed$
LINE INPUT "Filename (8 chars) ->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
IF filename$ = "" THEN EXIT SUB
numnotes = VAL(numnotes$)
RANDOMIZE VAL(seed$)
filename$ = filename$ + ".CEL"
OPEN filename$ FOR OUTPUT AS #1
FOR r = 1 TO numnotes
PRINT #1, CHR$(INT(RND * 256));
NEXT
CLOSE
END SUB
FUNCTION Round$ (initial$, newnote1$, scaletype, size)
'given the INITIAL$ notes, NEWNOTE1$ is frequency
'quantized to make it harmonize with these notes
available1$ = "c c+d d+e f f+g g+a a+b "
octaves$ = "X:X" + CHR$(34) + "X'X x x'x" + CHR$(34) + "x:x;x=x*"
'modify available$ to change key/scale
SELECT CASE scaletype
CASE 0 'chromatic
available$ = "c c+d d+e f f+g g+a a+b "
CASE 1 'whole tone starting on C
available$ = "c d e f+ g+ a+ "
CASE 2 'whole tone starting on C+
available$ = " c+ d+ f g a b "
CASE 3 'diatonic/c-major
available$ = "c d e f g a b "
CASE 4 'spooky
available$ = "c d d+ f g g+ a+ "
CASE 5 'black keys
available$ = " c+ d+ f+ g+ a+ "
CASE 6 'indian
available$ = "c c+ d+e f+g a a+ "
CASE ELSE
available$ = "c c+d d+e f f+g g+a a+b "
END SELECT
'go through all the notes in initial$ and take out
'all of their 'neighbors' in available$
at = 0
DO
at = at + 1
curnote1$ = GetWord$(initial$, at)
IF curnote1$ = "" THEN EXIT DO
curnote$ = LCASE$(MID$(curnote1$, 1, 1))
IF INSTR(curnote1$, "+") THEN curnote$ = curnote$ + "+" ELSE curnote$ = curnote$ + " "
x = INSTR(available1$, curnote$)
FOR r = 1 TO size
d1 = x - (2 * r)
IF d1 < 1 THEN d1 = d1 + 24
MID$(available$, d1, 2) = " "
d1 = x + (2 * r)
IF d1 > 23 THEN d1 = d1 - 24
MID$(available$, d1, 2) = " "
NEXT
LOOP
'now available$ has been cleared of clearly illegal
'notes and can be scanned for best fit
'make newnote1$ into a "featureless" note (newnote$)
newnote$ = LCASE$(MID$(newnote1$, 1, 1))
IF INSTR(newnote1$, "+") THEN newnote$ = newnote$ + "+" ELSE newnote$ = newnote$ + " "
'make a string, three octaves long
'if bottom octave, first string all spaces
'if top octave, third string all spaces
IF ASC(MID$(newnote1$, 1, 1)) < 72 AND INSTR(newnote1$, CHR$(34)) THEN s1$ = SPACE$(24) ELSE s1$ = available$
IF INSTR(newnote1$, "*") THEN s3$ = SPACE$(24) ELSE s3$ = available$
scan$ = s1$ + available$ + s3$
'locate start point in second octave set
startloc = INSTR(available1$, newnote$) + 24
'check if note is already ok. if so, keep and exit
IF Trim$(MID$(scan$, startloc, 2)) <> "" THEN
Round$ = newnote1$
EXIT FUNCTION
END IF
'scan up one, down one, until a non blank is hit
offset = 2
DO
IF startloc + offset < LEN(scan$) THEN
IF Trim$(MID$(scan$, startloc + offset, 2)) <> "" THEN
foundat = startloc + offset
GOTO found
END IF
END IF
IF startloc - offset > 0 THEN
IF Trim$(MID$(scan$, startloc - offset, 2)) <> "" THEN
foundat = startloc - offset
GOTO found
END IF
END IF
offset = offset + 2
IF offset > 100 THEN
Round$ = "": EXIT FUNCTION
END IF
LOOP
'when note is hit, grab octave, check for case change,
'write new note, and exit
' X:X"X'X x x'x"x:x;x=x*
found:
IF ASC(MID$(newnote1$, 1, 1)) < 72 THEN octscan$ = "X" ELSE octscan$ = "x"
IF RIGHT$(newnote1$, 1) <> "+" AND LEN(newnote1$) <> 1 THEN octscan$ = octscan$ + RIGHT$(newnote1$, 1) ELSE octscan$ = octscan$ + " "
curoct = INSTR(octaves$, octscan$)
IF foundat < 25 THEN
curoct = curoct - 2
ELSEIF foundat > 48 THEN
curoct = curoct + 2
END IF
IF curoct < 1 THEN curoct = 1
newnote$ = Trim$(MID$(scan$, foundat, 2))
IF MID$(octaves$, curoct, 1) = "X" THEN newnote$ = UCASE$(newnote$)
Round$ = Trim$(newnote$ + MID$(octaves$, curoct + 1, 1))
END FUNCTION
SUB Save
'Save the sequence array
x$ = DIR$("*.DGS")
IF x$ <> "" THEN
PRINT x$,
DO
x$ = DIR$
IF x$ = "" THEN EXIT DO
PRINT x$,
LOOP
END IF
PRINT
LINE INPUT "Filename (8 chars) -->", filename$
filename$ = Trim$(filename$)
IF filename$ = "" THEN EXIT SUB
filename$ = filename$ + ".DGS"
OPEN filename$ FOR OUTPUT AS #1
FOR r1 = 1 TO 11
PRINT ".";
FOR r2 = 1 TO 3
FOR r3 = 0 TO 500
PRINT #1, MKI$(notes(r1, r2, r3));
NEXT
NEXT
NEXT
CLOSE #1
END SUB
SUB SaveText (filename$)
IF filename$ = "" THEN
LINE INPUT "Filename (8 chars) -->", filename$
filename$ = Trim$(filename$)
IF filename$ = "" THEN EXIT SUB
filename$ = filename$ + ".TXT"
END IF
OPEN filename$ FOR OUTPUT AS #1
'find top timeloc
top = 0
FOR r = 1 TO 11
topc = notes(r, 1, 0)
IF topc <> 0 THEN
topc = notes(r, 1, topc) + notes(r, 3, topc)
END IF
IF topc > top THEN top = topc
NEXT
REDIM last(1 TO 11)
FOR c = 1 TO 11: last(c) = 0: NEXT
IF filename$ <> "SEQ.TXT" THEN PRINT #1, "0-----1-----2-----3-----4-----5-----6-----7-----8-----9-----10---- 1"
FOR t = 1 TO top
temp$ = ""
FOR c = 1 TO 11
'check note starts at chan c, time t
'check note ends at chan c, time t
'or blank
IF last(c) <= notes(c, 1, 0) THEN
sn = last(c) + 1
timeloc = notes(c, 1, sn)
noteend = notes(c, 1, last(c)) + notes(c, 3, last(c))
IF timeloc = t AND last(c) < notes(c, 1, 0) THEN
x$ = Num2Note$(notes(c, 2, sn))
n$ = " "
LSET n$ = x$
temp$ = temp$ + n$
last(c) = last(c) + 1
ELSEIF noteend = t THEN
temp$ = temp$ + "***"
ELSE
temp$ = temp$ + " "
END IF
IF filename$ <> "SEQ.TXT" THEN temp$ = temp$ + " | "
ELSE
temp$ = temp$ + "***"
END IF
NEXT
IF filename$ <> "SEQ.TXT" THEN temp$ = RTRIM$(temp$) + HEX$((t - 1) MOD 16)
PRINT #1, temp$
IF t MOD 16 = 0 THEN
IF filename$ <> "SEQ.TXT" THEN PRINT #1, "0-----1-----2-----3-----4-----5-----6-----7-----8-----9-----10----"; ((t \ 16) + 1)
END IF
NEXT
CLOSE #1
ERASE last
END SUB
FUNCTION ScaleNum (initial, irlo, irhi, orlo, orhi, inv)
'rescales an INITIAL number, range IRLO-IRHI to a
'number in the range ORLO-ORHI. if boolean INV is
'true, then the conversion is inverted
top = irhi - irlo
temp = initial - irlo 'temp is in range 0-top
IF inv THEN temp = top - temp 'invert if needed
newtop = orhi - orlo
ScaleNum = orlo + ((newtop / top) * temp)
END FUNCTION
FUNCTION Trim$ (orig$)
Trim$ = LTRIM$(RTRIM$(orig$))
END FUNCTION
SUB ViewComp
'find top timeloc
top = 0
FOR r = 1 TO 11
topc = notes(r, 1, 0)
IF topc <> 0 THEN
topc = notes(r, 1, topc) + notes(r, 3, topc)
END IF
IF topc > top THEN top = topc
NEXT
IF top = 0 THEN top = 640
mult# = 639 / top
PRINT mult#
SCREEN 12
FOR r = 0 TO 11
LINE (0, (r * 24) + 5)-(639, (r * 24) + 5), 1
NEXT
FOR r = 1 TO top + 16 STEP 16
r1 = (mult# * r) - 1
LINE (r1, 5)-(r1, 269), 1
NEXT
LINE (639, 5)-(639, 269), 1
FOR c = 1 TO 11
col = 16 - c
IF col < 9 THEN col = col - 1
FOR n = 1 TO notes(c, 1, 0)
r1 = (mult# * (notes(c, 1, n))) - 1
r2 = (mult# * ((notes(c, 1, n)) + (notes(c, 3, n)) - 1)) - 1
v = 250 - (notes(c, 2, n) * 2)
LINE (r1, v)-(r2, v), col
NEXT
NEXT
LOCATE 30, 1
PRINT "--Press any key to return to menu--";
DO UNTIL INKEY$ <> "": LOOP
SCREEN 0
END SUB
SUB Wave
CLS
PRINT "Dilaudid Glide"
PRINT "Music Authoring System ( X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
PRINT STRING$(80, "-")
PRINT
PRINT "Wave type:"
PRINT " / \ /\ -"
PRINT " /| |\ / \ / \"
PRINT " / | | \ / \ | |"
PRINT "/ | | \ / \ _/ \_"
PRINT "1.UP 2.DN 3.TRI 4.SINE"
PRINT
LINE INPUT "Wave type ---------->", WaveType$
LINE INPUT "Notes/cycle -------->", notesper$
LINE INPUT "Number of cycles --->", nocycles$
LINE INPUT "Filename (8 chars) ->", filename$
PRINT
LINE INPUT "Proceed? (y/N) ----->", x$
IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
IF filename$ = "" THEN EXIT SUB
WaveType = VAL(WaveType$)
notesper = VAL(notesper$)
nocycles = VAL(nocycles$)
filename$ = filename$ + ".CEL"
OPEN filename$ FOR OUTPUT AS #1
FOR c = 1 TO nocycles
SELECT CASE WaveType
CASE 1 'up triangle wave
FOR n = 1 TO notesper
x = ScaleNum(n, 1, notesper, 0, 255, 0)
PRINT #1, CHR$(x);
NEXT
CASE 2 'down triangle wave
FOR n = notesper TO 1 STEP -1
x = ScaleNum(n, 1, notesper, 0, 255, 0)
PRINT #1, CHR$(x);
NEXT
CASE 3 'full triangle wave
n2 = notesper \ 2
FOR n = 1 TO n2
x = ScaleNum(n, 1, n2, 0, 255, 0)
PRINT #1, CHR$(x);
NEXT
r1 = ScaleNum(2, 1, n2, 0, 255, 0)
r2 = ScaleNum(n2 - 1, 1, n2, 0, 255, 0)
FOR n = (notesper \ 2) TO 1 STEP -1
x = ScaleNum(n, 1, n2, r1, r2, 0)
PRINT #1, CHR$(x);
NEXT
CASE 4 'sine wave
FOR n = 1 TO notesper
n2# = ((n - 1) / (notesper - 1)) * 6.2
x2# = SIN(n2#)
x = (x2# + 1) * 127
PRINT #1, CHR$(x);
NEXT
END SELECT
NEXT
CLOSE
END SUB
FUNCTION words (text$)
temp = 1
FOR r = 1 TO LEN(text$)
IF MID$(text$, r, 1) = " " THEN temp = temp + 1
NEXT
words = temp
END FUNCTION